home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / packages / apropos.el.z / apropos.el
Encoding:
Text File  |  1998-05-21  |  22.5 KB  |  677 lines
  1. ;;; apropos.el --- apropos commands for users and programmers.
  2.  
  3. ;; Copyright (C) 1989, 1994, 1995 Free Software Foundation, Inc.
  4.  
  5. ;; Author: Joe Wells <jbw@bigbird.bu.edu>
  6. ;; Rewritten: Daniel.Pfeiffer@Informatik.START.dbp.de, fax (+49 69) 7588-2389
  7. ;; Keywords: help
  8.  
  9. ;; This file is part of XEmacs.
  10.  
  11. ;; XEmacs is free software; you can redistribute it and/or modify it
  12. ;; under the terms of the GNU General Public License as published by
  13. ;; the Free Software Foundation; either version 2, or (at your option)
  14. ;; any later version.
  15.  
  16. ;; XEmacs is distributed in the hope that it will be useful, but
  17. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19. ;; General Public License for more details.
  20.  
  21. ;; You should have received a copy of the GNU General Public License
  22. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24. ;; Boston, MA 02111-1307, USA.
  25.  
  26. ;;; Synched up with: FSF 19.34.
  27.  
  28. ;;; Commentary:
  29.  
  30. ;; The ideas for this package were derived from the C code in
  31. ;; src/keymap.c and elsewhere.  The functions in this file should
  32. ;; always be byte-compiled for speed.  Someone should rewrite this in
  33. ;; C (as part of src/keymap.c) for speed.
  34.  
  35. ;; The idea for super-apropos is based on the original implementation
  36. ;; by Lynn Slater <lrs@esl.com>.
  37.  
  38. ;; History:
  39. ;; Fixed bug, current-local-map can return nil.
  40. ;; Change, doesn't calculate key-bindings unless needed.
  41. ;; Added super-apropos capability, changed print functions.
  42. ;;; Made fast-apropos and super-apropos share code.
  43. ;;; Sped up fast-apropos again.
  44. ;; Added apropos-do-all option.
  45. ;;; Added fast-command-apropos.
  46. ;; Changed doc strings to comments for helping functions.
  47. ;;; Made doc file buffer read-only, buried it.
  48. ;; Only call substitute-command-keys if do-all set.
  49.  
  50. ;; Optionally use configurable faces to make the output more legible.
  51. ;; Differentiate between command, function and macro.
  52. ;; Apropos-command (ex command-apropos) does cmd and optionally user var.
  53. ;; Apropos shows all 3 aspects of symbols (fn, var and plist)
  54. ;; Apropos-documentation (ex super-apropos) now finds all it should.
  55. ;; New apropos-value snoops through all values and optionally plists.
  56. ;; Reading DOC file doesn't load nroff.
  57. ;; Added hypertext following of documentation, mouse-2 on variable gives value
  58. ;;   from buffer in active window.
  59.  
  60. ;;; Code:
  61.  
  62. ;; I see a degradation of maybe 10-20% only.
  63. ;; [sb -- FSF protects the face declarations with `if window-system'
  64. ;;  I see no reason why we should do so]
  65. (defvar apropos-do-all nil
  66.   "*Whether the apropos commands should do more.
  67. Slows them down more or less.  Set this non-nil if you have a fast machine.")
  68.  
  69. ;; XEmacs addition
  70. (defvar apropos-symbol-face (if (boundp 'font-lock-keyword-face)
  71.                 font-lock-keyword-face
  72.                   'bold)
  73.   "*Face for symbol name in apropos output or `nil'.  
  74. This looks good, but slows down the commands several times.")
  75.  
  76. ;; XEmacs addition
  77. (defvar apropos-keybinding-face (if (boundp 'font-lock-string-face)
  78.                     font-lock-string-face
  79.                   'underline)
  80.   "*Face for keybinding display in apropos output or `nil'.  
  81. This looks good, but slows down the commands several times.")
  82.  
  83. ;; XEmacs addition
  84. (defvar apropos-label-face (if (boundp 'font-lock-comment-face)
  85.                    font-lock-comment-face
  86.                  'italic)
  87.   "*Face for label (Command, Variable ...) in apropos output or `nil'.
  88. If this is `nil' no mouse highlighting occurs.
  89. This looks good, but slows down the commands several times.
  90. When this is a face name, as it is initially, it gets transformed to a
  91. text-property list for efficiency.")
  92.  
  93. ;; XEmacs addition
  94. (defvar apropos-property-face (if (boundp 'font-lock-variable-name-face)
  95.                   font-lock-variable-name-face
  96.                 'bold-italic)
  97.   "*Face for property name in apropos output or `nil'.  
  98. This looks good, but slows down the commands several times.")
  99.  
  100. (defvar apropos-match-face 'secondary-selection
  101.   "*Face for matching part in apropos-documentation/value output or `nil'.  
  102. This looks good, but slows down the commands several times.")
  103.  
  104.  
  105. (defvar apropos-mode-map
  106.   (let ((map (make-sparse-keymap)))
  107.     (define-key map [(control m)] 'apropos-follow)
  108.     (define-key map [(button2up)] 'apropos-mouse-follow)
  109.     (define-key map [(button2)] 'undefined)
  110.     map)
  111.   "Keymap used in Apropos mode.")
  112.  
  113.  
  114. (defvar apropos-regexp nil
  115.   "Regexp used in current apropos run.")
  116.  
  117. (defvar apropos-files-scanned ()
  118.   "List of elc files already scanned in current run of `apropos-documentation'.")
  119.  
  120. (defvar apropos-accumulator ()
  121.   "Alist of symbols already found in current apropos run.")
  122.  
  123. (defvar apropos-item ()
  124.   "Current item in or for apropos-accumulator.")
  125.  
  126. (defvar apropos-mode-hook nil) ; XEmacs
  127.  
  128. (defun apropos-mode ()
  129.   "Major mode for following hyperlinks in output of apropos commands.
  130.  
  131. \\{apropos-mode-map}"
  132.   (interactive)
  133.   (kill-all-local-variables)
  134.   (use-local-map apropos-mode-map)
  135.   (setq major-mode 'apropos-mode
  136.     mode-name "Apropos")
  137.   (run-hooks 'apropos-mode-hook)) ; XEmacs
  138.  
  139.  
  140. ;; For auld lang syne:
  141. ;;;###autoload
  142. (fset 'command-apropos 'apropos-command)
  143. ;;;###autoload
  144. (defun apropos-command (apropos-regexp &optional do-all)
  145.   "Shows commands (interactively callable functions) that match REGEXP.
  146. With optional prefix ARG or if `apropos-do-all' is non-nil, also show
  147. variables."
  148.   (interactive (list (read-string (concat "Apropos command "
  149.                       (if (or current-prefix-arg
  150.                           apropos-do-all)
  151.                           "or variable ")
  152.                       "(regexp): "))
  153.              current-prefix-arg))
  154.   (let ((message
  155.      (let ((standard-output (get-buffer-create "*Apropos*")))
  156.        (print-help-return-message 'identity))))
  157.     (or do-all (setq do-all apropos-do-all))
  158.     (setq apropos-accumulator
  159.       (apropos-internal apropos-regexp
  160.                 (if do-all
  161.                 (lambda (symbol) (or (commandp symbol)
  162.                              (user-variable-p symbol)))
  163.                   'commandp)))
  164.     (if (apropos-print
  165.      t
  166.      (lambda (p)
  167.        (let (doc symbol)
  168.          (while p
  169.            (setcar p (list
  170.               (setq symbol (car p))
  171.               (if (commandp symbol)
  172.                   (if (setq doc
  173.                     ;; XEmacs change: if obsolete,
  174.                     ;; only mention that.
  175.                     (or (function-obsoleteness-doc symbol)
  176.                         (documentation symbol t)))
  177.                   (substring doc 0 (string-match "\n" doc))
  178.                 "(not documented)"))
  179.               (and do-all
  180.                    (user-variable-p symbol)
  181.                    (if (setq doc
  182.                      (or
  183.                       ;; XEmacs change: if obsolete,
  184.                       ;; only mention that.
  185.                       (variable-obsoleteness-doc symbol)
  186.                       (documentation-property
  187.                        symbol 'variable-documentation t)))
  188.                    (substring doc 0
  189.                           (string-match "\n" doc))))))
  190.            (setq p (cdr p)))))
  191.      nil)
  192.     (and message (message message)))))
  193.  
  194.  
  195. ;;;###autoload
  196. (defun apropos (apropos-regexp &optional do-all)
  197.   "Show all bound symbols whose names match REGEXP.
  198. With optional prefix ARG or if `apropos-do-all' is non-nil, also show unbound
  199. symbols and key bindings, which is a little more time-consuming.
  200. Returns list of symbols and documentation found."
  201.   (interactive "sApropos symbol (regexp): \nP")
  202.   ;; XEmacs change: hitting ENTER by mistake is a common mess-up and
  203.   ;; shouldn't make Emacs hang for a long time trying to list all symbols.
  204.   (or (> (length apropos-regexp) 0)
  205.       (error "Must pass non-empty regexp to `apropos'"))
  206.   (setq apropos-accumulator
  207.     (apropos-internal apropos-regexp
  208.               (and (not do-all)
  209.                    (not apropos-do-all)
  210.                    (lambda (symbol)
  211.                  (or (fboundp symbol)
  212.                      (boundp symbol)
  213.                      (find-face symbol)
  214.                      (symbol-plist symbol))))))
  215.   (apropos-print
  216.    (or do-all apropos-do-all)
  217.    (lambda (p)
  218.      (let (symbol doc)
  219.        (while p
  220.      (setcar p (list
  221.             (setq symbol (car p))
  222.             (if (fboundp symbol)
  223.             (if (setq doc
  224.                   ;; XEmacs change: if obsolete,
  225.                   ;; only mention that.
  226.                   (or (function-obsoleteness-doc symbol)
  227.                       (documentation symbol t)))
  228.                 (substring doc 0 (string-match "\n" doc))
  229.               "(not documented)"))
  230.             (if (boundp symbol)
  231.             (if (setq doc
  232.                   (or
  233.                    ;; XEmacs change: if obsolete,
  234.                    ;; only mention that.
  235.                    (variable-obsoleteness-doc symbol)
  236.                    (documentation-property
  237.                     symbol 'variable-documentation t)))
  238.                 (substring doc 0
  239.                        (string-match "\n" doc))
  240.               "(not documented)"))
  241.             (if (setq doc (symbol-plist symbol))
  242.             (if (eq (/ (length doc) 2) 1)
  243.                 (format "1 property (%s)" (car doc))
  244.               (concat (/ (length doc) 2) " properties")))
  245.             (if (get symbol 'widget-type)
  246.             (if (setq doc (documentation-property
  247.                        symbol 'widget-documentation t))
  248.                 (substring doc 0
  249.                        (string-match "\n" doc))
  250.               "(not documented)"))
  251.             (if (find-face symbol)
  252.             (if (setq doc (face-doc-string symbol))
  253.                 (substring doc 0
  254.                        (string-match "\n" doc))
  255.               "(not documented)"))
  256.             (when (get symbol 'custom-group)
  257.               (if (setq doc (documentation-property
  258.                      symbol 'group-documentation t))
  259.               (substring doc 0
  260.                      (string-match "\n" doc))
  261.             "(not documented)"))))
  262.      (setq p (cdr p)))))
  263.    nil))
  264.  
  265.  
  266. ;;;###autoload
  267. (defun apropos-value (apropos-regexp &optional do-all)
  268.   "Show all symbols whose value's printed image matches REGEXP.
  269. With optional prefix ARG or if `apropos-do-all' is non-nil, also looks
  270. at the function and at the names and values of properties.
  271. Returns list of symbols and values found."
  272.   (interactive "sApropos value (regexp): \nP")
  273.   (or do-all (setq do-all apropos-do-all))
  274.   (setq apropos-accumulator ())
  275.    (let (f v p)
  276.      (mapatoms
  277.       (lambda (symbol)
  278.     (setq f nil v nil p nil)
  279.     (or (memq symbol '(apropos-regexp do-all apropos-accumulator
  280.                       symbol f v p))
  281.         (setq v (apropos-value-internal 'boundp symbol 'symbol-value)))
  282.     (if do-all
  283.         (setq f (apropos-value-internal 'fboundp symbol 'symbol-function)
  284.           p (apropos-format-plist symbol "\n    " t)))
  285.     (if (or f v p)
  286.         (setq apropos-accumulator (cons (list symbol f v p)
  287.                         apropos-accumulator))))))
  288.   (apropos-print nil nil t))
  289.  
  290.  
  291. ;;;###autoload
  292. (defun apropos-documentation (apropos-regexp &optional do-all)
  293.   "Show symbols whose documentation contain matches for REGEXP.
  294. With optional prefix ARG or if `apropos-do-all' is non-nil, also use
  295. documentation that is not stored in the documentation file and show key
  296. bindings.
  297. Returns list of symbols and documentation found."
  298.   (interactive "sApropos documentation (regexp): \nP")
  299.   (or do-all (setq do-all apropos-do-all))
  300.   (setq apropos-accumulator () apropos-files-scanned ())
  301.   (let ((standard-input (get-buffer-create " apropos-temp"))
  302.     f v)
  303.     (unwind-protect
  304.     (save-excursion
  305.       (set-buffer standard-input)
  306.       (apropos-documentation-check-doc-file)
  307.       (if do-all
  308.           (mapatoms
  309.            (lambda (symbol)
  310.          (setq f (apropos-safe-documentation symbol)
  311.                v (get symbol 'variable-documentation))
  312.          (if (integerp v) (setq v))
  313.          (setq f (apropos-documentation-internal f)
  314.                v (apropos-documentation-internal v))
  315.          (if (or f v)
  316.              (if (setq apropos-item
  317.                    (cdr (assq symbol apropos-accumulator)))
  318.              (progn
  319.                (if f
  320.                    (setcar apropos-item f))
  321.                (if v
  322.                    (setcar (cdr apropos-item) v)))
  323.                (setq apropos-accumulator
  324.                  (cons (list symbol f v)
  325.                    apropos-accumulator)))))))
  326.       (apropos-print nil nil t))
  327.       (kill-buffer standard-input))))
  328.  
  329.  
  330. (defun apropos-value-internal (predicate symbol function)
  331.   (if (funcall predicate symbol)
  332.       (progn
  333.     (setq symbol (prin1-to-string (funcall function symbol)))
  334.     (if (string-match apropos-regexp symbol)
  335.         (progn
  336.           (if apropos-match-face
  337.           (put-text-property (match-beginning 0) (match-end 0)
  338.                      'face apropos-match-face
  339.                      symbol))
  340.           symbol)))))
  341.  
  342. (defun apropos-documentation-internal (doc)
  343.   (if (consp doc)
  344.       (apropos-documentation-check-elc-file (car doc))
  345.     (and doc
  346.      (string-match apropos-regexp doc)
  347.      (progn
  348.        (if apropos-match-face
  349.            (put-text-property (match-beginning 0)
  350.                   (match-end 0)
  351.                   'face apropos-match-face
  352.                   (setq doc (copy-sequence doc))))
  353.        doc))))
  354.  
  355. (defun apropos-format-plist (pl sep &optional compare)
  356.   (setq pl (symbol-plist pl))
  357.   (let (p p-out)
  358.     (while pl
  359.       (setq p (format "%s %S" (car pl) (nth 1 pl)))
  360.       (if (or (not compare) (string-match apropos-regexp p))
  361.       (if apropos-property-face
  362.           (put-text-property 0 (length (symbol-name (car pl)))
  363.                  'face apropos-property-face p))
  364.     (setq p nil))
  365.       (if p
  366.       (progn
  367.         (and compare apropos-match-face
  368.          (put-text-property (match-beginning 0) (match-end 0)
  369.                     'face apropos-match-face
  370.                     p))
  371.         (setq p-out (concat p-out (if p-out sep) p))))
  372.       (setq pl (nthcdr 2 pl)))
  373.     p-out))
  374.  
  375.  
  376. ;; Finds all documentation related to APROPOS-REGEXP in internal-doc-file-name.
  377.  
  378. (defun apropos-documentation-check-doc-file ()
  379.   (let (type symbol (sepa 2) sepb beg end)
  380.     (insert ?\^_)
  381.     (backward-char)
  382.     (insert-file-contents (concat doc-directory internal-doc-file-name))
  383.     (forward-char)
  384.     (while (save-excursion
  385.          (setq sepb (search-forward "\^_"))
  386.          (not (eobp)))
  387.       (beginning-of-line 2)
  388.       (if (save-restriction
  389.         (narrow-to-region (point) (1- sepb))
  390.         (re-search-forward apropos-regexp nil t))
  391.       (progn
  392.         (setq beg (match-beginning 0)
  393.           end (point))
  394.         (goto-char (1+ sepa))
  395.         (or (setq type (if (eq ?F (preceding-char))
  396.                    1    ; function documentation
  397.                  2)        ; variable documentation
  398.               symbol (read)
  399.               beg (- beg (point) 1)
  400.               end (- end (point) 1)
  401.               doc (buffer-substring (1+ (point)) (1- sepb))
  402.               apropos-item (assq symbol apropos-accumulator))
  403.         (setq apropos-item (list symbol nil nil)
  404.               apropos-accumulator (cons apropos-item
  405.                         apropos-accumulator)))
  406.         (if apropos-match-face
  407.         (put-text-property beg end 'face apropos-match-face doc))
  408.         (setcar (nthcdr type apropos-item) doc)))
  409.       (setq sepa (goto-char sepb)))))
  410.  
  411. (defun apropos-documentation-check-elc-file (file)
  412.   (if (member file apropos-files-scanned)
  413.       nil
  414.     (let (symbol doc beg end this-is-a-variable)
  415.       (setq apropos-files-scanned (cons file apropos-files-scanned))
  416.       (erase-buffer)
  417.       (insert-file-contents file)
  418.       (while (search-forward "\n#@" nil t)
  419.     ;; Read the comment length, and advance over it.
  420.     (setq end (read)
  421.           beg (1+ (point))
  422.           end (+ (point) end -1))
  423.     (forward-char)
  424.     (if (save-restriction
  425.           ;; match ^ and $ relative to doc string
  426.           (narrow-to-region beg end)
  427.           (re-search-forward apropos-regexp nil t))
  428.         (progn
  429.           (goto-char (+ end 2))
  430.           (setq doc (buffer-substring beg end)
  431.             end (- (match-end 0) beg)
  432.             beg (- (match-beginning 0) beg)
  433.             this-is-a-variable (looking-at "(def\\(var\\|const\\) ")
  434.             symbol (progn
  435.                  (skip-chars-forward "(a-z")
  436.                  (forward-char)
  437.                  (read))
  438.             symbol (if (consp symbol)
  439.                    (nth 1 symbol)
  440.                  symbol))
  441.           (if (if this-is-a-variable
  442.               (get symbol 'variable-documentation)
  443.             (and (fboundp symbol) (apropos-safe-documentation symbol)))
  444.           (progn
  445.             (or (setq apropos-item (assq symbol apropos-accumulator))
  446.             (setq apropos-item (list symbol nil nil)
  447.                   apropos-accumulator (cons apropos-item
  448.                             apropos-accumulator)))
  449.             (if apropos-match-face
  450.             (put-text-property beg end 'face apropos-match-face
  451.                        doc))
  452.             (setcar (nthcdr (if this-is-a-variable 2 1)
  453.                     apropos-item)
  454.                 doc)))))))))
  455.  
  456.  
  457.  
  458. (defun apropos-safe-documentation (function)
  459.   "Like documentation, except it avoids calling `get_doc_string'.
  460. Will return nil instead."
  461.   (while (and function (symbolp function))
  462.     (setq function (if (fboundp function)
  463.                (symbol-function function))))
  464.   (if (eq (car-safe function) 'macro)
  465.       (setq function (cdr function)))
  466.   ;; XEmacs change from: (setq function (if (byte-code-function-p function)
  467.   (setq function (if (compiled-function-p function)
  468.              (if (fboundp 'compiled-function-doc-string)
  469.              (compiled-function-doc-string function)
  470.                (if (> (length function) 4)
  471.                (aref function 4)))
  472.            (if (eq (car-safe function) 'autoload)
  473.                (nth 2 function)
  474.              (if (eq (car-safe function) 'lambda)
  475.              (if (stringp (nth 2 function))
  476.                  (nth 2 function)
  477.                (if (stringp (nth 3 function))
  478.                    (nth 3 function)))))))
  479.   (if (integerp function)
  480.       nil
  481.     function))
  482.  
  483.  
  484.  
  485. (defun apropos-print (do-keys doc-fn spacing)
  486.   "Output result of various apropos commands with `apropos-regexp'.
  487. APROPOS-ACCUMULATOR is a list.  Optional DOC-FN is called for each element
  488. of apropos-accumulator and may modify it resulting in (symbol fn-doc
  489. var-doc [plist-doc]).  Returns sorted list of symbols and documentation
  490. found."
  491.   (if (null apropos-accumulator)
  492.       (message "No apropos matches for `%s'" apropos-regexp)
  493.     (if doc-fn
  494.     (funcall doc-fn apropos-accumulator))
  495.     (setq apropos-accumulator
  496.       (sort apropos-accumulator (lambda (a b)
  497.                       (string-lessp (car a) (car b)))))
  498.     (and apropos-label-face
  499.      (or (symbolp apropos-label-face)
  500.          (facep apropos-label-face)) ; XEmacs
  501.      (setq apropos-label-face `(face ,apropos-label-face
  502.                      mouse-face highlight)))
  503.     (with-output-to-temp-buffer "*Apropos*"
  504.       (let ((p apropos-accumulator)
  505.         (old-buffer (current-buffer))
  506.         symbol item point1 point2)
  507.     (set-buffer standard-output)
  508.     (apropos-mode)
  509.         ;; XEmacs change from (if window-system
  510.     (if (device-on-window-system-p)
  511.         (insert "If you move the mouse over text that changes color,\n"
  512.             (substitute-command-keys
  513.              "you can click \\[apropos-mouse-follow] to get more information.\n")))
  514.     (insert (substitute-command-keys
  515.          "Type \\[apropos-follow] in this buffer to get full documentation.\n\n"))
  516.     (while (consp p)
  517.       (or (not spacing) (bobp) (terpri))
  518.       (setq apropos-item (car p)
  519.         symbol (car apropos-item)
  520.         p (cdr p)
  521.         point1 (point))
  522.       (princ symbol)                ; print symbol name
  523.       (setq point2 (point))
  524.       ;; Calculate key-bindings if we want them.
  525.       (and do-keys
  526.            (commandp symbol)
  527.            (indent-to 30 1)
  528.            (if (let ((keys
  529.               (save-excursion
  530.                 (set-buffer old-buffer)
  531.                 (where-is-internal symbol)))
  532.              filtered)
  533.              ;; Copy over the list of key sequences,
  534.              ;; omitting any that contain a buffer or a frame.
  535.              (while keys
  536.                (let ((key (car keys))
  537.                  (i 0)
  538.                  loser)
  539.              (while (< i (length key))
  540.                (if (or (framep (aref key i))
  541.                    (bufferp (aref key i)))
  542.                    (setq loser t))
  543.                (setq i (1+ i)))
  544.              (or loser
  545.                  (setq filtered (cons key filtered))))
  546.                (setq keys (cdr keys)))
  547.              (setq item filtered))
  548.            ;; Convert the remaining keys to a string and insert.
  549.            (insert
  550.             (mapconcat
  551.              (lambda (key)
  552.                (setq key (key-description key))
  553.                (if apropos-keybinding-face
  554.                (put-text-property 0 (length key)
  555.                           'face apropos-keybinding-face
  556.                           key))
  557.                key)
  558.              item ", "))
  559.          (insert "Type ")
  560.          (insert "M-x")
  561.          (put-text-property (- (point) 3) (point)
  562.                     'face apropos-keybinding-face)
  563.          (insert " " (symbol-name symbol) " ")
  564.          (insert "RET")
  565.          (put-text-property (- (point) 3) (point)
  566.                     'face apropos-keybinding-face)))
  567.       (terpri)
  568.       ;; only now so we don't propagate text attributes all over
  569.       (put-text-property point1 point2 'item
  570.                  (if (eval `(or ,@(cdr apropos-item)))
  571.                  (car apropos-item)
  572.                    apropos-item))
  573.       (if apropos-symbol-face
  574.           (put-text-property point1 point2 'face apropos-symbol-face))
  575.       (apropos-print-doc 'describe-function 1
  576.                  (if (commandp symbol)
  577.                  "Command"
  578.                    (if (apropos-macrop symbol)
  579.                    "Macro"
  580.                  "Function"))
  581.                  do-keys)
  582.       (if (get symbol 'custom-type)
  583.           (apropos-print-doc 'customize-variable-other-window 2
  584.                  "User Option" do-keys)
  585.         (apropos-print-doc 'describe-variable 2
  586.                    "Variable" do-keys))
  587.       (apropos-print-doc 'customize-other-window 6 "Group" do-keys)
  588.       (apropos-print-doc 'customize-face-other-window 5 "Face" do-keys)
  589.       (apropos-print-doc 'widget-browse-other-window 4 "Widget" do-keys)
  590.       (apropos-print-doc 'apropos-describe-plist 3
  591.                  "Plist" nil)))))
  592.   (prog1 apropos-accumulator
  593.     (setq apropos-accumulator ())))    ; permit gc
  594.  
  595.  
  596. (defun apropos-macrop (symbol)
  597.   "T if SYMBOL is a Lisp macro."
  598.   (and (fboundp symbol)
  599.        (consp (setq symbol
  600.             (symbol-function symbol)))
  601.        (or (eq (car symbol) 'macro)
  602.        (if (eq (car symbol) 'autoload)
  603.            (memq (nth 4 symbol)
  604.              '(macro t))))))
  605.  
  606.  
  607. (defun apropos-print-doc (action i str do-keys)
  608.   (if (stringp (setq i (nth i apropos-item)))
  609.       (progn
  610.     (insert "  ")
  611.     (put-text-property (- (point) 2) (1- (point))
  612.                'action action)
  613.     (insert str ": ")
  614.     (if apropos-label-face
  615.         (add-text-properties (- (point) (length str) 2)
  616.                  (1- (point))
  617.                  apropos-label-face))
  618.     (insert (if do-keys (substitute-command-keys i) i))
  619.     (or (bolp) (terpri)))))
  620.  
  621. (defun apropos-mouse-follow (event)
  622.   (interactive "e")
  623.   (let ((other (if (eq (current-buffer) (get-buffer "*Apropos*"))
  624.            ()
  625.          (current-buffer))))
  626.     (save-excursion
  627.       ;; XEmacs change from:
  628.       ;; (set-buffer (window-buffer (posn-window (event-start event))))
  629.       ;; (goto-char (posn-point (event-start event)))
  630.       (set-buffer (event-buffer event))
  631.       (goto-char (event-closest-point event))
  632.       ;; XEmacs change: following code seems useless
  633.       ;;(or (and (not (eobp)) (get-text-property (point) 'mouse-face))
  634.       ;;      (and (not (bobp)) (get-text-property (1- (point)) 'mouse-face))
  635.       ;;      (error "There is nothing to follow here"))
  636.       (apropos-follow other))))
  637.  
  638.  
  639. (defun apropos-follow (&optional other)
  640.   (interactive)
  641.   (let* (;; Properties are always found at the beginning of the line.
  642.      (bol (save-excursion (beginning-of-line) (point)))
  643.      ;; If there is no `item' property here, look behind us.
  644.      (item (get-text-property bol 'item))
  645.      (item-at (if item nil (previous-single-property-change bol 'item)))
  646.      ;; Likewise, if there is no `action' property here, look in front.
  647.      (action (get-text-property bol 'action))
  648.      (action-at (if action nil (next-single-property-change bol 'action))))
  649.     (and (null item) item-at
  650.      (setq item (get-text-property (1- item-at) 'item)))
  651.     (and (null action) action-at
  652.      (setq action (get-text-property action-at 'action)))
  653.     (if (not (and item action))
  654.     (error "There is nothing to follow here"))
  655.     (if (consp item) (error "There is nothing to follow in `%s'" (car item)))
  656.     (if other (set-buffer other))
  657.     (funcall action item)))
  658.  
  659.  
  660.  
  661. (defun apropos-describe-plist (symbol)
  662.   "Display a pretty listing of SYMBOL's plist."
  663.   (with-output-to-temp-buffer "*Help*"
  664.     (set-buffer standard-output)
  665.     (princ "Symbol ")
  666.     (prin1 symbol)
  667.     (princ "'s plist is\n (")
  668.     (if apropos-symbol-face
  669.     (put-text-property 8 (- (point) 14) 'face apropos-symbol-face))
  670.     (insert (apropos-format-plist symbol "\n  "))
  671.     (princ ")")
  672.     (print-help-return-message)))
  673.  
  674. (provide 'apropos) ; XEmacs
  675.  
  676. ;;; apropos.el ends here
  677.